home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / tm / tm-image.el.z / tm-image.el
Encoding:
Text File  |  1998-05-21  |  6.4 KB  |  227 lines
  1. ;;; tm-image.el --- tm-view filter to display images in XEmacs or MULE buffers
  2.  
  3. ;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko
  4. ;; Copyright (C) 1996 Dan Rich
  5.  
  6. ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  7. ;;         Dan Rich <drich@morpheus.corp.sgi.com>
  8. ;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  9. ;; Created: 1995/12/15
  10. ;; Version: $Id: tm-image.el,v 7.31 1997/07/14 21:50:01 morioka Exp $
  11.  
  12. ;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news
  13.  
  14. ;; This file is part of XEmacs.
  15.  
  16. ;; This program is free software; you can redistribute it and/or
  17. ;; modify it under the terms of the GNU General Public License as
  18. ;; published by the Free Software Foundation; either version 2, or (at
  19. ;; your option) any later version.
  20.  
  21. ;; This program is distributed in the hope that it will be useful, but
  22. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  23. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  24. ;; General Public License for more details.
  25.  
  26. ;; You should have received a copy of the GNU General Public License
  27. ;; along with GNU XEmacs; see the file COPYING.  If not, write to the
  28. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  29. ;; Boston, MA 02111-1307, USA.
  30.  
  31. ;;; Commentary:
  32. ;;    If you use this program with MULE, please install
  33. ;;    etl8x16-bitmap.bdf font included in tl package.
  34.  
  35. ;;; Code:
  36.  
  37. (require 'tm-view)
  38.  
  39. (cond (running-xemacs
  40.        (require 'images)
  41.        
  42.        (defun-maybe image-inline-p (format)
  43.      (or (memq format image-native-formats)
  44.          (find-if (function
  45.                (lambda (native)
  46.              (image-converter-chain format native)
  47.              ))
  48.               image-native-formats)
  49.          ))
  50.        
  51.        (image-register-netpbm-utilities)
  52.        (image-register-converter 'pic 'ppm "pictoppm")
  53.        (image-register-converter 'mag 'ppm "magtoppm")
  54.        
  55.        (defun bitmap-insert-xbm-file (file)
  56.      (let ((gl (make-glyph (list (cons 'x file))))
  57.            (e (make-extent (point) (point)))
  58.            )
  59.        (set-extent-end-glyph e gl)
  60.        ))
  61.        
  62.        ;;
  63.        ;; X-Face
  64.        ;;
  65.        (autoload 'highlight-headers "highlight-headers")
  66.        
  67.        (defun mime-preview/x-face-function-use-highlight-headers ()
  68.      (highlight-headers (point-min) (re-search-forward "^$" nil t) t)
  69.      )
  70.        
  71.        (add-hook 'mime-viewer/content-header-filter-hook
  72.          'mime-preview/x-face-function-use-highlight-headers)
  73.        
  74.        )
  75.       ((featurep 'mule)
  76.        ;; for MULE 2.* or mule merged EMACS
  77.        (require 'x-face-mule)
  78.  
  79.        (defvar image-native-formats '(xbm))
  80.        
  81.        (defun-maybe image-inline-p (format)
  82.      (memq format image-native-formats)
  83.      )
  84.        
  85.        (defun-maybe image-normalize (format data)
  86.      (and (eq format 'xbm)
  87.           (vector 'xbm ':data data)
  88.           ))
  89.        
  90.        ;;
  91.        ;; X-Face
  92.        ;;
  93.        (if (exec-installed-p uncompface-program)
  94.        (add-hook 'mime-viewer/content-header-filter-hook
  95.              'x-face-decode-message-header)
  96.      )
  97.        ))
  98.  
  99. (or (fboundp 'image-invalid-glyph-p)
  100.     (defsubst image-invalid-glyph-p (glyph)
  101.       (or (null (aref glyph 0))
  102.       (null (aref glyph 2))
  103.       (equal (aref glyph 2) "")
  104.       ))
  105.     )
  106.  
  107. (defvar mime-viewer/image-converter-alist nil)
  108.  
  109. (mapcar (function
  110.      (lambda (rule)
  111.        (let ((ctype  (car rule))
  112.          (format (cdr rule))
  113.          )
  114.          (if (image-inline-p format)
  115.          (progn
  116.            (set-alist 'mime-viewer/content-filter-alist
  117.                   ctype
  118.                   (function mime-preview/filter-for-image))
  119.            (set-alist 'mime-viewer/image-converter-alist
  120.                   ctype format)
  121.            (add-to-list
  122.             'mime-viewer/default-showing-Content-Type-list
  123.             ctype)
  124.            )
  125.            ))))
  126.     '(("image/jpeg"            . jpeg)
  127.       ("image/gif"            . gif)
  128.       ("image/tiff"            . tiff)
  129.       ("image/x-tiff"        . tiff)
  130.       ("image/xbm"            . xbm)
  131.       ("image/x-xbm"        . xbm)
  132.       ("image/x-xpixmap"        . xpm)
  133.       ("image/x-pic"        . pic)
  134.       ("image/x-mag"        . mag)
  135.       ("image/png"            . png)
  136.       ))
  137.  
  138. (defvar mime-viewer/ps-to-gif-command "pstogif")
  139.  
  140.  
  141. ;;; @ content filter for images
  142. ;;;
  143. ;;    (for XEmacs 19.12 or later)
  144.  
  145. (defun mime-preview/filter-for-image (ctype params encoding)
  146.   (let* ((mode mime::preview/original-major-mode)
  147.      (m (assq mode mime-viewer/code-converter-alist))
  148.      (charset (assoc "charset" params))
  149.      (beg (point-min)) (end (point-max))
  150.      )
  151.     (remove-text-properties beg end '(face nil))
  152.     (message "Decoding image...")
  153.     (mime-decode-region beg end encoding)
  154.     (let* ((minor (assoc-value ctype mime-viewer/image-converter-alist))
  155.        (gl (image-normalize minor (buffer-string)))
  156.        e)
  157.       (delete-region (point-min)(point-max))
  158.       (cond ;; ((image-invalid-glyph-p gl)
  159.          ;; (setq gl nil)
  160.          ;; (message "Invalid glyph!")
  161.          ;; )
  162.         ((eq (aref gl 0) 'xbm)
  163.          (let ((xbm-file
  164.             (make-temp-name (expand-file-name "tm" mime/tmp-dir))))
  165.            (insert (aref gl 2))
  166.            (write-region (point-min)(point-max) xbm-file)
  167.            (message "Decoding image...")
  168.            (delete-region (point-min)(point-max))
  169.            (bitmap-insert-xbm-file xbm-file)
  170.            (delete-file xbm-file)
  171.            )
  172.          (message "Decoding image... done")
  173.          )
  174.         (t
  175.          (setq gl (make-glyph gl))
  176.          (setq e (make-extent (point) (point)))
  177.          (set-extent-end-glyph e gl)
  178.          (message "Decoding image... done")
  179.          ))
  180.       )
  181.     (insert "\n")
  182.     ))
  183.  
  184.  
  185. ;;; @ content filter for Postscript
  186. ;;;
  187. ;;    (for XEmacs 19.14 or later)
  188.  
  189. (defun mime-preview/filter-for-application/postscript (ctype params encoding)
  190.   (let* ((mode mime::preview/original-major-mode)
  191.      (m (assq mode mime-viewer/code-converter-alist))
  192.      (beg (point-min)) (end (point-max))
  193.      (file-base (make-temp-name (expand-file-name "tm" mime/tmp-dir)))
  194.      (ps-file (concat file-base ".ps"))
  195.      (gif-file (concat file-base ".gif"))
  196.      )
  197.     (remove-text-properties beg end '(face nil))
  198.     (message "Decoding Postscript...")
  199.     (mime-decode-region beg end encoding)
  200.     (write-region (point-min)(point-max) ps-file) 
  201.     (message "Decoding Postscript...")
  202.     (delete-region (point-min)(point-max))
  203.     (call-process mime-viewer/ps-to-gif-command nil nil nil ps-file)
  204.     (set-extent-end-glyph (make-extent (point) (point))
  205.               (make-glyph (vector 'gif :file gif-file)))
  206.     (message "Decoding Postscript... done")
  207.     (delete-file ps-file)
  208.     (delete-file gif-file)
  209.     ))
  210.  
  211. (set-alist 'mime-viewer/content-filter-alist
  212.        "application/postscript"
  213.        (function mime-preview/filter-for-application/postscript))
  214.  
  215. (if (featurep 'gif)
  216.     (add-to-list 'mime-viewer/default-showing-Content-Type-list
  217.          "application/postscript")
  218.   )
  219.  
  220.  
  221. ;;; @ end
  222. ;;;
  223.  
  224. (provide 'tm-image)
  225.  
  226. ;;; tm-image.el ends here
  227.